home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / boostrs.arc / BOOSTERS.PAS < prev    next >
Pascal/Delphi Source File  |  1985-11-19  |  45KB  |  1,301 lines
  1.        { -------------------        Boosters       ------------------- }
  2.        {                              v1.0                             }
  3.        {                                                               }
  4.        {                  Utilities for Turbo Pascal (tm)              }
  5.        {                                                               }
  6.        {                       Copyright (C) 1985                      }
  7.        {                       All Rights Reserved                     }
  8.        {                                                               }
  9.        {                              by                               }
  10.        {                                                               }
  11.        {                         George Smith                          }
  12.        {                      609 Candlewick Lane                      }
  13.        {                       Lilburn, GA 30247                       }
  14.        {                        (404) 923-6879                         }
  15.        {                                                               }
  16.        {                                                               }
  17.        {                                                               }
  18.        {    Boosters users:  A $25 contribution would be appreciated   }
  19.        {                     if you find these utilities of value.     }
  20.        {                                                               }
  21.        {                     Or if you prefer, become a registered     }
  22.        {                     user for $35 and receive a printed users  }
  23.        {                     guide, update notices, and the latest     }
  24.        {                     version of Boosters.                      }
  25.        {                                                               }
  26.        {    Turbo Pascal is a Registered Trademark of Borland, Inc.    }
  27.        {                                                               }
  28.        {---------------------------------------------------------------}
  29.  
  30. { ----------------------------------------------
  31.   EXEC invokes compiled programs and batch files
  32.   then returns control to caller.
  33.   ---------------------------------------------- }
  34. Procedure Exec  ( VAR FileDesc, CommandLine  : AnyString;
  35.                   VAR Code                   : Integer);
  36.                                                external 'TBX.COM';
  37.  
  38. { ------------------------
  39.   FILLHEAP fills heap page
  40.   character/attribute
  41.   block
  42.   ------------------------ }
  43. Procedure FillHeap ( Page : HeapBuf;
  44.                        X1 : RowType;
  45.                        Y1 : ColumnType;
  46.                        X2 : RowType;
  47.                        Y2 : ColumnType;
  48.                         C : Char;
  49.                       Att : Byte); external 'FillHeap.com';
  50.           { Fill Page from (X1,Y1) to (X2,Y2)
  51.             with C character and Att byte }
  52.  
  53. { ---------------
  54.   CENTER a string
  55.   --------------- }
  56.  
  57. Function CENTER ( A : AnyString;
  58.                   N : Integer;
  59.                   Pad : Char )  : AnyString;
  60.                   { AnyString is type String[255] }
  61.  
  62. begin
  63.    InLine ($1E/ $8D/$9E/$08/$01/ $8B/$46/$06/ $36/$88/$07/ $43/
  64.            $8A/$4E/$08/ $30/$ED/ $29/$C8/ $77/$05/ $31/$C0/ $EB/$12/$90/
  65.            $D1/$E8/ $50/ $8B/$FB/ $8B/$46/$04/ $8B/$4E/$06/ $16/ $07/
  66.            $FC/ $F3/$AA/ $58/ $01/$C3/ $8B/$FB/ $8D/$76/$09/ $16/ $1F/
  67.            $8A/$4E/$08/ $30/$ED/ $FC/ $F3/$A4/ $1F);
  68. end { Center };
  69.  
  70.  
  71. { ---------------------------------------------------
  72.   PUTSTR  - Write a string directly to display memory
  73.   --------------------------------------------------- }
  74.  
  75. Procedure PutStr ( HV : Char;
  76.                     S : AnyString;
  77.                     X : ColumnType;
  78.                     Y : RowType;
  79.                   Att : Byte );
  80.  
  81. begin
  82.    InLine ($1E/ $BB/$49/$04/ $31/$C0/ $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/
  83.            $BA/$00/$B0/ $EB/$0C/$90/ $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/ 
  84.            $BA/$00/$B8/ $8E/$C2/ $8B/$5E/$08/ $09/$DB/ $74/$0C/ $4B/
  85.            $8B/$46/$06/ $48/ $8A/$F0/ $8A/$D3/ $EB/$05/$90/ $B4/$03/
  86.            $CD/$10/ $8A/$DE/ $30/$FF/ $8B/$C3/ $B1/$07/ $D3/$E0/ $B1/$05/
  87.            $D3/$E3/ $01/$C3/ $8A/$C2/ $30/$E4/ $D1/$E0/ $01/$C3/ $8B/$FB/
  88.            $8A/$4E/$0A/ $30/$ED/ $8D/$76/$0B/ $16/ $1F/ $8A/$66/$04/
  89.            $8B/$96/$0A/$01/ $80/$FA/$76/ $74/$0A/ $80/$FA/$56/ $74/$05/
  90.            $31/$D2/ $EB/$04/$90/ $BA/$9E/$00/ $FC/ $8A/$04/ $AB/ $01/$D7/
  91.            $46/ $E2/$F8/ $09/$D2/ $74/$04/ $81/$EF/$9E/$00/ $8B/$C7/
  92.            $31/$D2/ $BB/$A0/$00/ $F7/$F3/ $D0/$EA/ $8A/$F0/ $B4/$02/
  93.            $CD/$10/ $1F/$5D);
  94. end { PutStr };
  95.  
  96. { -------------------------------------------------
  97.   PUTHEAP  - Write a string to Page [n] of the heap
  98.   ------------------------------------------------- }
  99.  
  100. Procedure PutHeap ( PAGE : HeapBuf;
  101.                       HV : Char;
  102.                        S : AnyString;
  103.                        X : ColumnType;
  104.                        Y : RowType;
  105.                      Att : Byte );
  106.                      external 'PutHeap.com';
  107.  
  108. { -------------------------------
  109.   COPIES characters into a string
  110.   ------------------------------- }
  111. Function COPIES (C : Char;
  112.                  N : Integer ): AnyString;
  113.                 { AnyString is Type string[255] }
  114. begin
  115.    InLine ($16/ $07/ $8B/$4E/$04/ $88/$4E/$08/ $8B/$46/$06/ $8D/$7E/$09/
  116.            $FC/ $F3/$AA );
  117. end { Copies };
  118.  
  119.  
  120. { ------------------------------------------
  121.   COPYSTR returns N concatenated copies of S
  122.   ------------------------------------------ }
  123. Function CopyStr ( S : AnyString;
  124.                    N : Integer ) : AnyString;
  125.  
  126. Begin
  127.    InLine ($1E/ $8B/$4E/$04/ $83/$F9/$00/ $7F/$09/
  128.            $C7/$86/$06/$01/$00/$00/ $EB/$46/$90/ $8A/$56/$06/ $30/$F6/
  129.            $51/ $8B/$C2/ $49/ $83/$F9/$00/ $74/$04/ $01/$D0/ $E2/$FC/
  130.            $8B/$CA/ $5A/ $3D/$FF/$00/ $76/$06/ $B8/$FF/$00/ $EB/$07/$90/
  131.            $3C/$00/ $73/$02/ $31/$C0/ $88/$86/$06/$01/ $3C/$00/ $74/$17/
  132.            $8C/$D3/ $8E/$C3/ $8E/$DB/ $8D/$BE/$07/$01/ $8D/$76/$07/ $FC/
  133.            $51/ $56/ $F3/$A4/ $5E/ $59/ $4A/ $75/$F7/ $1F );
  134. end { CopyStr };
  135.  
  136.  
  137.  
  138. { --------------------------------
  139.   LEFT justify a string in a field
  140.   -------------------------------- }
  141. Function LEFT ( S : AnyString;
  142.                 N : Integer;
  143.                 Pad : Char ) : AnyString;
  144.                 { AnyString is Type string[255] }
  145. begin
  146.    InLine ($1E/ $8D/$76/$09/ $8D/$9E/$08/$01/ $8B/$46/$06/ $36/$88/$07/
  147.            $43/ $8A/$4E/$08/ $30/$ED/ $29/$C8/ $77/$05/ $31/$C0/
  148.            $EB/$0F/$90/ $8B/$FB/ $01/$CF/ $8B/$C8/ $8B/$46/$04/ $16/ $07/
  149.            $FC/ $F3/$AA/ $8B/$FB/ $16/ $1F/ $8A/$4E/$08/ $30/$ED/ $FC/
  150.            $F3/$A4/ $1F );
  151. end { Left };
  152.  
  153. { --------------------------------
  154.   RIGHT justify a string in a field
  155.   -------------------------------- }
  156. Function RIGHT ( S : AnyString;
  157.                  N : Integer;
  158.                  Pad : Char ) : AnyString;
  159.                  { AnyString is Type string[255] }
  160. begin
  161.    InLine ($1E/ $8C/$D0/ $8E/$C0/ $8E/$D8/ $8D/$BE/$09/$01/ $8B/$46/$06/
  162.            $88/$86/$08/$01/ $8A/$4E/$08/ $30/$ED/ $8D/$76/$09/ $01/$CE/
  163.            $4E/ $29/$C8/ $77/$06/ $8B/$4E/$06/ $EB/$0C/$90/ $8B/$C8/
  164.            $8B/$46/$04/ $FC/ $F3/$AA/ $8A/$4E/$08/ $01/$CF/ $4F/ $FD/
  165.            $F3/$A4/ $1F/$5D);
  166. end { Right };
  167.  
  168. { ------------------------------------------------
  169.   COPYBLK copies one part of the screen to another
  170.   ------------------------------------------------ }
  171.   Procedure COPYBLK (  X1 : ColumnType;
  172.                        Y1 : RowType;
  173.                        X2 : ColumnType;
  174.                        Y2 : RowType;
  175.                        X3 : ColumnType;
  176.                        Y3 : RowType );
  177.  
  178. {           Copies block defined by upper left and lower right
  179.             coordinates (X1,Y1),(X2,Y2) to a block beginning
  180.             at upper left coordinates (X3,Y3).                }
  181.  
  182. begin
  183.    InLine ($1E/ $BB/$49/$04/ $31/$C0/ $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/
  184.            $BA/$00/$B0/ $EB/$0C/$90/ $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/
  185.            $BA/$00/$B8/ $52/ $8B/$5E/$0C/ $4B/ $8B/$D3/ $B1/$07/ $D3/$E2/
  186.            $B1/$05/ $D3/$E3/ $01/$D3/ $8B/$46/$0E/ $48/ $D1/$E0/ $01/$C3/
  187.            $8B/$F3/ $1F/ $1E/ $8B/$5E/$04/ $4B/ $8B/$D3/ $B1/$07/
  188.            $D3/$E2/ $B1/$05/ $D3/$E3/ $01/$D3/ $8B/$46/$06/ $48/ $D1/$E0/
  189.            $01/$C3/ $8B/$FB/ $07/ $8B/$46/$0C/ $8B/$56/$08/ $29/$C2/ $42/
  190.            $8B/$46/$0E/ $8B/$4E/$0A/ $29/$C1/ $41/  $51/ $FC/ $F3/$A5/
  191.            $59/ $4A/ $74/$0F/ $8B/$D9/ $D1/$E3/ $B8/$A0/$00/ $29/$D8/
  192.            $01/$C6/ $01/$C7/ $EB/$E9/  $1F);
  193. end { CopyBlk };
  194.  
  195. Procedure CblkHeap ( Page : HeapBuf;
  196.                        X1 : ColumnType;
  197.                        Y1 : RowType;
  198.                        X2 : ColumnType;
  199.                        Y2 : RowType;
  200.                        X3 : ColumnType;
  201.                        Y3 : RowType ); external 'CblkHeap.Com';
  202.  
  203. { ------------------------------------------------
  204.   MOVEBLK moves one part of the screen to another
  205.   ------------------------------------------------ }
  206.   Procedure MOVEBLK (  X1 : ColumnType;
  207.                        Y1 : RowType;
  208.                        X2 : ColumnType;
  209.                        Y2 : RowType;
  210.                        X3 : ColumnType;
  211.                        Y3 : RowType );
  212.  
  213. {           Moves block defined by upper left and lower right
  214.             coordinates (X1,Y1),(X2,Y2) to a block beginning
  215.             at upper left coordinates (X3,Y3).  The orginal block
  216.             is erased. }
  217.  
  218. begin
  219.    InLine ($1E/ $8B/$46/$0C/ $8B/$4E/$08/ $29/$C1/ $41/ $8B/$46/$0E/
  220.            $8B/$56/$0A/ $29/$C2/ $42/ $D1/$E2/ $8B/$D9/ $29/$D4/ $E2/$FC/
  221.            $8C/$D0/ $8E/$C0/ $8B/$FC/ $52/ $53/ $BB/$49/$04/ $31/$C0/
  222.            $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/ $BA/$00/$B0/ $EB/$0C/$90/
  223.            $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/  $BA/$00/$B8/  $8E/$DA/
  224.            $8B/$76/$0C/ $4E/ $8B/$D6/ $B1/$07/ $D3/$E2/ $B1/$05/ $D3/$E6/
  225.            $01/$D6/ $8B/$46/$0E/ $48/ $D1/$E0/ $01/$C6/ $5A/ $59/
  226.            $D1/$E9/ $1E/ $56/ $52/ $51/ $B8/$A0/$00/ $29/$C8/ $29/$C8/
  227.            $FC/ $51/ $F3/$A5/ $59/ $4A/ $74/$04/ $01/$C6/ $EB/$F5/ $59/
  228.            $5A/ $5F/ $07/ $52/ $51/ $BB/$A0/$00/ $29/$CB/ $29/$CB/
  229.            $B8/$20/$0E/ $FC/ $51/ $F3/$AB/ $59/ $4A/ $74/$04/ $01/$DF/
  230.            $EB/$F5/ $8B/$7E/$04/ $4F/ $8B/$D7/ $B1/$07/ $D3/$E2/ $B1/$05/
  231.            $D3/$E7/ $01/$D7/ $8B/$46/$06/ $48/ $D1/$E0/ $01/$C7/ $59/
  232.            $5A/ $8B/$F4/ $8C/$D0/ $8E/$D8/ $B8/$A0/$00/ $29/$C8/ $29/$C8/
  233.            $FC/ $51/ $F3/$A5/ $59/ $4A/ $74/$04/ $01/$C7/ $EB/$F5/
  234.            $8B/$E5/ $83/$EC/$04/ $1F/$5D);
  235. end { MoveBlk };
  236.  
  237. Procedure MBLKHEAP ( Page : HeapBuf;
  238.                        X1 : ColumnType;
  239.                        Y1 : RowType;
  240.                        X2 : ColumnType;
  241.                        Y2 : RowType;
  242.                        X3 : ColumnType;
  243.                        Y3 : RowType); external 'MblkHeap.Com';
  244.  
  245. { ---------------------------------------------
  246.   REMBLK blanks a specified area of the display
  247.   --------------------------------------------- }
  248. Procedure REMBLK ( X1,Y1,X2,Y2 : Integer);
  249. begin
  250.    InLine ($1E/ $8B/$46/$08/ $8B/$56/$04/ $29/$C2/ $42/ $52/ $8B/$46/$0A/
  251.            $8B/$4E/$06/ $29/$C1/ $41/ $51/ $BB/$49/$04/ $31/$C0/ $8E/$D8/
  252.            $8A/$07/ $3C/$07/ $75/$06/ $BA/$00/$B0/ $EB/$0C/$90/
  253.            $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/  $BA/$00/$B8/ $8E/$C2/
  254.            $8B/$7E/$08/ $4F/ $8B/$D7/ $B1/$07/ $D3/$E2/ $B1/$05/ $D3/$E7/
  255.            $01/$D7/ $8B/$46/$0A/ $48/ $D1/$E0/ $01/$C7/ $59/ $5A/
  256.            $B8/$20/$0E/ $FC/ $51/ $F3/$AB/ $59/ $4A/ $74/$0A/
  257.            $81/$C7/$A0/$00/ $29/$CF/ $29/$CF/ $EB/$EF/ $1F);
  258. end { RemBlk };
  259.  
  260. { ---------------------------------------------
  261.   SETATT sets attribute byte for specified area
  262.   --------------------------------------------- }
  263. Procedure SETATT ( X1,Y1,X2,Y2 : Integer;
  264.                    Attribute   : Byte);
  265. begin
  266.    InLine ($1E/ $8B/$46/$0A/ $8B/$56/$06/ $29/$C2/ $42/ $52/ $8B/$46/$0C/
  267.            $8B/$4E/$08/ $29/$C1/ $41/ $51/ $BB/$49/$04/ $31/$C0/ $8E/$D8/
  268.            $8A/$07/ $3C/$07/ $75/$06/ $BA/$00/$B0/ $EB/$0C/$90/
  269.            $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/  $BA/$00/$B8/ $8E/$C2/
  270.            $8B/$7E/$0A/ $4F/ $8B/$D7/ $B1/$07/ $D3/$E2/ $B1/$05/ $D3/$E7/
  271.            $01/$D7/ $8B/$46/$0C/ $48/ $D1/$E0/ $01/$C7/ $47/ $59/ $5A/
  272.            $8B/$46/$04/ $FC/ $51/ $AA/ $47/ $E2/$FC/ $59/ $4A/ $74/$0A/
  273.            $81/$C7/$A0/$00/ $29/$CF/ $29/$CF/ $EB/$ED/ $1F/$5D);
  274. end { SetAtt };
  275.  
  276.  
  277. { ----------------------------------------------
  278.   HEAPAT sets attribute byte on Page [n] of heap
  279.   ---------------------------------------------- }
  280. Procedure HEAPAT ( Page : HeapBuf;
  281.                    X1,Y1,X2,Y2 : Integer;
  282.                    Attribute   : Byte);
  283.                    external 'Heapat.com';
  284.  
  285. { ------------------------------------------------
  286.   MOVEBG moves one part of the screen to another,
  287.          while preserving the background.
  288.   ------------------------------------------------ }
  289.   Procedure MOVEBG ( Page : HeapBuf;
  290.                        X1 : ColumnType;
  291.                        Y1 : RowType;
  292.                        X2 : ColumnType;
  293.                        Y2 : RowType;
  294.                        X3 : ColumnType;
  295.                        Y3 : RowType );
  296.      external 'Movebg.com';
  297.  
  298.  {          Type HeapBuf = ^AnyBuf;
  299.                   AnyBuf = record
  300.                               Screen : array[1..4000] of byte;
  301.                            end;
  302.  
  303.             Moves block defined by upper left and lower right
  304.             coordinates (X1,Y1),(X2,Y2) to a block beginning
  305.             at upper left coordinates (X3,Y3).  The orginal
  306.             block is saved, the background 'Page' refreshed,
  307.             then the block is redisplayed at its new position. }
  308.  
  309.  
  310. { ----------------------------------------------
  311.   FINDSTR searches for the first occurrence of S
  312.   in video memory beginning from X,Y.
  313.   ---------------------------------------------- }
  314. Procedure FindStr ( X : ColumnType;
  315.                     Y : RowType;
  316.                     S : AnyString;
  317.                     N : Integer;
  318.             var Ecode : Integer ); external 'FindStr.com';
  319. {
  320.            Ecode = 0 if S is found on screen
  321.            Ecode = 1 if S not found
  322.             if N = 0, cursor placed at S[1]
  323.             if N < 0, cursor placed at Nth position from left end of S
  324.             if N > 0, cursor placed at Nth position from right end of S }
  325.  
  326. { -----------------------------------------
  327.   FSTRHEAP searches Page on the heap for
  328.   the first occurrence of S.  If S found,
  329.   FstrHeap sets X,Y to the address of S[1].
  330.   If not found, X = 0.
  331.   ----------------------------------------- }
  332. Procedure FstrHeap ( Page : HeapBuf;
  333.                         S : AnyString;
  334.                     var X : ColumnType;
  335.                     var Y : RowType ); external 'FstrHeap.com';
  336.  
  337.  
  338. { ------------------------------------------------
  339.   GETSTR reads string at X,Y into S for length LEN
  340.   ------------------------------------------------ }
  341.   Procedure GETSTR (    HV : Char;
  342.                      VAR S : AnyString;
  343.                          X : ColumnType;
  344.                          Y : RowType;
  345.                        LEN : Integer);
  346.                        external 'GetStr.com';
  347.  
  348. {                    If X=Y=0, then read begins at current cursor
  349.                      position.  Otherwise read begins at (X,Y).
  350.                      HV = 'V' or 'v', read is top-to-bottom.
  351.                      Otherwise read is left-to-right.
  352.                      On exit, cursor points to one beyond last
  353.                      byte read.   }
  354.  
  355.   Procedure GETHEAP ( Page : HeapBuf;
  356.                         HV : Char;
  357.                      VAR S : AnyString;
  358.                          X : ColumnType;
  359.                          Y : RowType;
  360.                        LEN : Integer ); external 'GetHeap.com';
  361.  
  362. {     GetHeap gets strings from the heap.  X,Y must be valid
  363.       coordinates--zero not allowed.  GetHeap is useful for
  364.       getting small portions of the heap }
  365.  
  366. { ------------------------------------------------
  367.   UPPER function converts alphabetics to uppercase
  368.   ------------------------------------------------ }
  369. Function UPPER  ( S : AnyString) : AnyString;
  370. begin
  371.    InLine ($1E/ $8A/$4E/$04/ $30/$ED/ $8D/$76/$05/ $8D/$BE/$04/$01/
  372.            $36/$88/$0D/ $80/$F9/$00/ $76/$18/ $47/ $8C/$D0/ $8E/$D8/
  373.            $8E/$C0/ $FC/ $8A/$04/ $3C/$61/ $72/$06/ $3C/$7A/ $77/$02/
  374.            $2C/$20/ $AA/ $46/ $E2/$F0/ $1F);
  375. end { Upper };
  376.  
  377. { --------------------------------------------
  378.   OVERSTR overlays and pads target string with
  379.   new string
  380.   -------------------------------------------- }
  381.   Function OVERSTR ( NEW, TARGET : AnyString;
  382.                           N, LEN : Integer;
  383.                              PAD : Char) : AnyString;
  384.  
  385. {                    NEW overlays TARGET beginning at position N of
  386.                      TARGET, for a length of LEN.  If LEN exceeds the
  387.                      length of NEW, NEW is padded on the right with
  388.                      PAD.   If N exceeds the length of TARGET, left-
  389.                      padding occurs before NEW is written. }
  390. begin
  391.    InLine ($1E/ $8C/$D0/ $8E/$C0/ $8E/$D8/ $8A/$4E/$0A/ $30/$ED/
  392.            $8D/$76/$0B/ $8D/$BE/$0B/$02/ $FC/ $F3/$A4/ $8A/$5E/$0A/
  393.            $30/$FF/ $8B/$4E/$06/ $83/$F9/$00/ $7C/$71/ $8B/$56/$08/
  394.            $83/$FA/$00/ $7C/$69/ $8D/$BE/$0B/$02/ $39/$DA/ $76/$30/
  395.            $81/$FA/$00/$FF/ $76/$03/ $BA/$00/$01/ $8B/$CA/ $29/$D9/ $49/
  396.            $8B/$46/$04/ $01/$DF/ $F3/$AA/ $8D/$BE/$0B/$02/ $8B/$4E/$06/
  397.            $01/$D1/ $81/$F9/$FF/$00/ $77/$06/ $8B/$4E/$06/ $EB/$07/$90/
  398.            $B9/$FF/$00/ $29/$D1/ $41/ $8A/$86/$0A/$01/ $30/$E4/ $51/
  399.            $39/$C1/ $72/$02/ $8B/$C8/ $8D/$B6/$0B/$01/ $01/$D7/ $4F/
  400.            $F3/$A4/ $59/ $39/$C1/ $76/$16/ $01/$D0/ $3D/$FF/$00/ $73/$0F/
  401.            $51/ $8A/$86/$0A/$01/ $30/$E4/ $29/$C1/ $8B/$46/$04/ $F3/$AA/
  402.            $59/ $8D/$8E/$0B/$02/ $29/$CF/ $39/$DF/ $77/$02/ $8B/$FB/
  403.            $8B/$C7/ $88/$86/$0A/$02/ $1F/$5D);
  404. end { OverStr };
  405.  
  406. { --------------------------------------
  407.   DOWS returns day of week for any valid
  408.   Gregorian Date
  409.   -------------------------------------- }
  410. Function DOWS( MM, DD, CCYY : Integer) : AnyString;
  411.  
  412. begin
  413.    InLine ($1E/ $E8/$A8/$00/ $EB/$0D/$90/ $00/$03/$02/$05/$00/$03/
  414.            $05/$01/$04/$06/$02/$04/ $83/$C3/$03/ $8B/$FB/ $8B/$5E/$08/
  415.            $8B/$4E/$06/ $8B/$56/$04/ $83/$FB/$03/ $73/$01/ $4A/ $01/$DF/
  416.            $4F/ $2E/$02/$0D/ $8B/$C2/ $BB/$64/$00/ $30/$FF/ $F6/$F3/ $51/
  417.            $50/ $B1/$02/ $D2/$CC/ $B1/$06/ $D2/$EC/ $8A/$DC/ $58/
  418.            $B1/$02/ $D2/$C8/ $B1/$06/ $D2/$E8/ $B1/$02/ $8A/$D4/ $D2/$EA/
  419.            $59/ $00/$D0/ $B7/$05/ $F6/$E7/ $30/$FF/ $01/$D8/ $01/$C8/
  420.            $BA/$07/$00/ $F6/$F2/ $8A/$C4/ $30/$E4/ $E8/$42/$00/
  421.            $EB/$46/$90/ $53/$75/$6E/$64/$61/$79/$20/$20/$20/
  422.            $4D/$6F/$6E/$64/$61/$79/$20/$20/$20/
  423.            $54/$75/$65/$73/$64/$61/$79/$20/$20/
  424.            $57/$65/$64/$6E/$65/$73/$64/$61/$79/
  425.            $54/$68/$75/$72/$73/$64/$61/$79/$20/
  426.            $46/$72/$69/$64/$61/$79/$20/$20/$20/
  427.            $53/$61/$74/$75/$72/$64/$61/$79/$20/ $8B/$DC/ $36/$8B/$1F/
  428.            $C3/ $83/$C3/$03/ $8B/$F3/ $B9/$09/$00/ $F6/$E1/ $01/$C6/ $0E/
  429.            $1F/ $16/ $07/ $88/$4E/$0A/ $8D/$7E/$0B/ $FC/ $F3/$A4/
  430.            $1F/$5D);
  431. end { Dows };
  432.  
  433. { -------------------------------------------
  434.   STRIP function removes leading and trailing
  435.   characters from a string.
  436.   ------------------------------------------- }
  437. Function STRIP ( S : AnyString;
  438.                  C : Char) : AnyString;
  439.                  { Removes all leading and trailing
  440.                    C characters from S }
  441. begin
  442.    InLine ($1E/ $8D/$7E/$07/ $8A/$4E/$06/ $30/$ED/ $8C/$D0/ $8E/$C0/
  443.            $8B/$46/$04/ $83/$F9/$01/ $77/$0E/ $8A/$5E/$07/ $30/$FF/
  444.            $39/$D8/ $74/$35/ $8B/$D7/ $EB/$1D/$90/ $FC/ $F3/$AE/ $E3/$2B/
  445.            $4F/ $8B/$D7/ $8A/$4E/$06/ $30/$ED/ $8D/$7E/$07/ $01/$CF/ $4F/
  446.            $FD/ $F3/$AE/ $47/ $8B/$CF/ $29/$D1/ $41/ $88/$8E/$06/$01/
  447.            $8B/$F2/ $8D/$BE/$07/$01/ $8C/$D0/ $8E/$D8/ $FC/ $F3/$A4/
  448.            $EB/$07/$90/ $C7/$86/$06/$01/$00/$00/ $1F/$5D);
  449. end { Strip };
  450.  
  451. { ---------------------
  452.   Upper Left Box
  453.   --------------------- }
  454. Procedure BOXUL ( Start_Col, Start_Row,
  455.                   End_Col,   End_Row,   Style   : Integer;
  456.                   Attribute  : Byte);
  457.  
  458. Var
  459.    Ver_Adj, Hor_Adj, Num_Col, Num_Row : Integer;
  460.  
  461. Const
  462.                                   { DOWN  LL  OVER  LR   UR   UL }
  463.    s : array[1..4,1..6] of char = ((#179,#192,#196,#217,#191,#218),
  464.                                    (#186,#200,#205,#188,#187,#201),
  465.                                    (#186,#211,#196,#189,#183,#214),
  466.                                    (#179,#212,#205,#190,#184,#213));
  467.  
  468. begin
  469.    if (style < 1) or (style > 4) then
  470.       style := 1;
  471.    Num_Col := End_Col - Start_Col + 1;
  472.    Num_Row := End_Row - Start_Row + 1;
  473.    if Num_Col <= 2 then
  474.       Num_Col := 3;
  475.    if Num_Row <= 2 then
  476.       Num_Row := 3;
  477.    Ver_Adj := Num_Row - 2;
  478.    Hor_Adj := Num_Col - 2;
  479.  
  480.    PUTSTR ( V, s[style,6],
  481.                Start_Col, Start_Row, Attribute);             { UL Corner  }
  482.  
  483.    PUTSTR ( V, COPIES( s[style,1], Ver_Adj),
  484.                Start_Col,  Start_Row + 1, Attribute);        { Left Side  }
  485.  
  486.    PUTSTR ( V, s[style,2],
  487.                Start_Col, End_Row, Attribute);               { LL Corner  }
  488.  
  489.    PUTSTR ( H, COPIES( s[style,3], Hor_Adj),
  490.                Start_Col + 1, End_Row, Attribute);           { Bottom     }
  491.  
  492.    PUTSTR ( V, s[style,4],
  493.                End_Col, End_Row, Attribute);                 { LR Corner  }
  494.  
  495.    PUTSTR ( V, COPIES( s[style,1],Ver_Adj),
  496.                End_Col, Start_Row + 1, Attribute);           { Right Side }
  497.  
  498.    PUTSTR ( V, s[style,5],
  499.                End_Col, Start_Row, Attribute);               { UR Corner  }
  500.  
  501.    PUTSTR ( H, COPIES( s[style,3],Hor_Adj),
  502.                Start_Col + 1, Start_Row, Attribute);         { Top        }
  503.  
  504. end { Boxul };
  505.  
  506. { --------------------------------
  507.   BOXHEAP builds a box on the heap
  508.   at Page [n]
  509.   -------------------------------- }
  510. Procedure BoxHeap ( Page  :  HeapBuf;
  511.                     Start_Col, Start_Row,
  512.                     End_Col,   End_Row,   Style   : Integer;
  513.                     Attribute  : Byte);
  514.  
  515. Var
  516.    Ver_Adj, Hor_Adj, Num_Col, Num_Row : Integer;
  517.  
  518. Const
  519.                                   { DOWN  LL  OVER  LR   UR   UL }
  520.    s : array[1..4,1..6] of char = ((#179,#192,#196,#217,#191,#218),
  521.                                    (#186,#200,#205,#188,#187,#201),
  522.                                    (#186,#211,#196,#189,#183,#214),
  523.                                    (#179,#212,#205,#190,#184,#213));
  524.  
  525. begin
  526.    if (style < 1) or (style > 4) then
  527.       style := 1;
  528.    Num_Col := End_Col - Start_Col + 1;
  529.    Num_Row := End_Row - Start_Row + 1;
  530.    if Num_Col <= 2 then
  531.       Num_Col := 3;
  532.    if Num_Row <= 2 then
  533.       Num_Row := 3;
  534.    Ver_Adj := Num_Row - 2;
  535.    Hor_Adj := Num_Col - 2;
  536.  
  537.    PutHeap ( Page, V, s[style,6],
  538.                    Start_Col, Start_Row, Attribute);         { UL Corner  }
  539.  
  540.    PutHeap ( Page, V, COPIES( s[style,1], Ver_Adj),
  541.                    Start_Col,  Start_Row + 1, Attribute);    { Left Side  }
  542.  
  543.    PutHeap ( Page, V, s[style,2],
  544.                    Start_Col, End_Row, Attribute);           { LL Corner  }
  545.  
  546.    PutHeap ( Page, H, COPIES( s[style,3], Hor_Adj),
  547.                    Start_Col + 1, End_Row, Attribute);       { Bottom     }
  548.  
  549.    PutHeap ( Page, V, s[style,4],
  550.                    End_Col, End_Row, Attribute);             { LR Corner  }
  551.  
  552.    PutHeap ( Page, V, COPIES( s[style,1],Ver_Adj),
  553.                    End_Col, Start_Row + 1, Attribute);       { Right Side }
  554.  
  555.    PutHeap ( Page, V, s[style,5],
  556.                    End_Col, Start_Row, Attribute);           { UR Corner  }
  557.  
  558.    PutHeap ( Page, H, COPIES( s[style,3],Hor_Adj),
  559.                    Start_Col + 1, Start_Row, Attribute);     { Top        }
  560.  
  561. end { BoxHeap };
  562.  
  563.  
  564. { ----------------------
  565.   TIMER Boolean Function
  566.   ---------------------- }
  567. Function Timer ( Limit : integer) : Boolean;
  568.  
  569. { Note: Globals are:
  570.                  Type
  571.                     Result  = record
  572.                                 AX, BX, CX, DX, BP,
  573.                                 SI, DI, DS, ES, Flags : Integer;
  574.                               end;
  575.                  var
  576.                     regs : result;
  577.                     TimeElapsed,
  578.                     SaveElapsed   : Integer;
  579.                     StartElapsed  : Boolean = FALSE;
  580. }
  581. var
  582.    SecondsReading : Integer;
  583.  
  584. begin
  585.    with regs do
  586.    begin
  587.       if Limit <= 0 then
  588.          Timer := TRUE
  589.       else
  590.       begin
  591.          Timer := FALSE;
  592.          ax := $2C00;
  593.          intr($21,regs);
  594.  
  595.          if StartElapsed = FALSE then
  596.          begin
  597.             SaveElapsed  := hi(dx);
  598.             TimeElapsed  := 0;
  599.             StartElapsed := TRUE;
  600.             ax := $2D00;                { Set time . . .            }
  601.             dx := Swap(SaveElapsed);    { With hundredths = 0 . . . }
  602.             intr($21,regs);             { so that we start from 0   }
  603.             delay(70);                  { Helps DOS 3.1 work right  }
  604.          end
  605.          else
  606.          if SaveElapsed <> hi(dx) then
  607.          begin
  608.             SecondsReading := hi(dx);
  609.             if SaveElapsed > SecondsReading then
  610.                SecondsReading := SecondsReading + 60;
  611.             TimeElapsed := TimeElapsed + SecondsReading - SaveElapsed;
  612.             SaveElapsed := hi(dx);
  613.  
  614.             if TimeElapsed >= Limit then
  615.             begin
  616.                Timer := TRUE;
  617.                StartElapsed := FALSE;
  618.             end;
  619.          end;
  620.       end;
  621.    end;
  622. end { Timer };
  623.  
  624. { --------------------------
  625.   Display TIME of day at X,Y
  626.   -------------------------- }
  627. Procedure TimeXY (X : ColumnType;
  628.                   Y : RowType ) ;
  629. var
  630.    hour     : integer;
  631.    hr,
  632.    min, sec : string[2];
  633.  
  634. begin
  635.    with regs do
  636.    begin
  637.       ax := $2C00;
  638.       intr($21,regs);
  639.       hour := hi(cx);
  640.       if hour < 1 then
  641.          hour := 12
  642.       else
  643.       if hour > 12 then
  644.          hour := hour - 12;
  645.       str ( hour, hr );
  646.       str ( lo(cx), min );
  647.       str ( hi(dx), sec );
  648.       if length(min) < 2 then
  649.          min := '0'+min;
  650.       if length(sec) < 2 then
  651.          sec := '0'+sec;
  652.       PutStr( h,hr+':'+min+':'+sec, x,y,14);
  653.    end
  654. end { TimeXY };
  655.  
  656. { ---------------
  657.   SET TIME of day
  658.   --------------- }
  659. Procedure Stime ( hh, mm, ss : integer );
  660. begin
  661.    with regs do
  662.    begin
  663.       cx := swap(hh);
  664.       cx := cx or mm;
  665.       dx := swap(ss);
  666.       ax := $2D00;
  667.       intr($21,regs);
  668.    end;
  669. end { Stime };
  670.  
  671. { -----------------------------------
  672.   SAVESCREEN saves the current screen
  673.   ----------------------------------- }
  674. Procedure SaveScreen ( Page : HeapBuf);
  675.    external 'Saves.com';
  676.  
  677. { -------------------------------------
  678.   RESTORESCREEN restores a saved screen
  679.   ------------------------------------- }
  680. Procedure RestoreScreen ( Page : HeapBuf);
  681.    external 'Restores.com';
  682.  
  683. { ------------------------------------
  684.   CURSOROFF makes the cursor invisible
  685.   ------------------------------------ }
  686. Procedure CursorOff;
  687. begin
  688.    with regs do
  689.    begin
  690.       cx := $2000;
  691.       ax := $0100;
  692.       intr($10,regs);
  693.    end;
  694. end { CursorOff };
  695.  
  696. { ---------------------------------
  697.   CURSORON produces a normal cursor
  698.   --------------------------------- }
  699. Procedure CursorOn;
  700. begin
  701.    with regs do
  702.    begin
  703.       if VideoStatus = 7 then
  704.          cx := $0C0D  { Monochrome }
  705.       else
  706.          cx := $0607; { Color }
  707.       ax := $0100;
  708.       intr($10,regs);
  709.    end;
  710. end { CursorOn };
  711.  
  712. { --------------------------------------
  713.   WAIT for Timer to elapse or a KeyPress.
  714.   If KeyPress was HOME key, WAIT waits
  715.   for another KeyPress.
  716.   -------------------------------------- }
  717. Procedure Wait ( NumberOfSeconds : Integer);
  718. begin
  719.    repeat until Timer(NumberOfSeconds) or KeyPressed;
  720.    if KeyPressed then
  721.    begin
  722.       read(Kbd,ch);
  723.       StartElapsed := FALSE;
  724.       if (ch = #27) and KeyPressed then
  725.       begin
  726.          read(Kbd,ch);
  727.          if ch = #71 then
  728.          begin
  729.             repeat until KeyPressed;
  730.             read(Kbd,ch);
  731.             if (ch = #27 ) and KeyPressed then
  732.                read(Kbd,ch);
  733.          end;
  734.       end;
  735.    end;
  736. end { Wait };
  737.  
  738.  
  739. { --------------------------------
  740.   NSORBIT - Nancy's Orbiting Light
  741.   -------------------------------- }
  742. Procedure NsOrbit ( StartCol   , StartRow,
  743.                     EndCol     , EndRow,
  744.                     Style      , NumberOfSeconds : Integer);
  745. Var
  746.    NumberCols, NumberRows, I,
  747.    RowDelay, ColDelay : Integer;
  748. begin
  749.  
  750.    RowDelay := 3;
  751.    ColDelay := 1;
  752.    NumberCols := EndCol - StartCol + 1;
  753.    NumberRows := EndRow - StartRow + 1;
  754.  
  755.    BoxUL (StartCol, StartRow, EndCol, EndRow, Style, 14);
  756.  
  757.    repeat
  758.       for i := 0 to NumberCols - 1  do
  759.       begin
  760.          SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow, 14);
  761.          delay(ColDelay);
  762.          SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow,  0);
  763.          delay(ColDelay);
  764.          SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow,  14);
  765.          delay(ColDelay);
  766.          SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow,  0);
  767.          delay(ColDelay);
  768.       end;
  769.  
  770.       for i := 0 to NumberRows - 1  do
  771.       begin
  772.          SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i, 14);
  773.          delay(RowDelay);
  774.          SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i,  0);
  775.          delay(RowDelay);
  776.          SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i, 14);
  777.          delay(RowDelay);
  778.          SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i,  0);
  779.          delay(RowDelay);
  780.       end;
  781.  
  782.       for i := 0 to NumberCols - 1  do
  783.       begin
  784.          SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow, 14);
  785.          delay(ColDelay);
  786.          SetAtt ( StartCol+i, StartRow, StartCol+i, StartRow,  0);
  787.          delay(ColDelay);
  788.          SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow, 14);
  789.          delay(ColDelay);
  790.          SetAtt ( EndCol-i, EndRow, EndCol-i, EndRow,  0);
  791.          delay(ColDelay);
  792.       end;
  793.  
  794.       for i := 0 to NumberRows - 1  do
  795.       begin
  796.          SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i, 14);
  797.          delay(RowDelay);
  798.          SetAtt ( StartCol, EndRow-i, StartCol, EndRow-i,  0);
  799.          delay(RowDelay);
  800.          SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i, 14);
  801.          delay(RowDelay);
  802.          SetAtt ( EndCol, StartRow+i, EndCol, StartRow+i,  0);
  803.          delay(RowDelay);
  804.       end;
  805.    until Timer(NumberOfSeconds) or KeyPressed;
  806.    if KeyPressed then
  807.    begin
  808.       read(Kbd,ch);
  809.       StartElapsed := FALSE;
  810.    end;
  811.    BoxUL (StartCol, StartRow, EndCol, EndRow, Style, 14);
  812. end { NsOrbit };
  813.  
  814. { ---------------------------------
  815.   CALENDAR for given month and year
  816.   --------------------------------- }
  817. Procedure Calendar ( MM, CCYY, StartCol, StartRow : Integer);
  818. var
  819.    target     :   string[10];
  820.    year       :   string[4];
  821.    PreviousMonth,
  822.    NextMonth,
  823.    PreviousMonthLength,
  824.    NumDays,
  825.    Xpos, Ypos, StartDay,
  826.    i, j, day  :   integer;
  827.    Temp, Months,
  828.    Col, Row   :   AnyString;
  829.  
  830. const
  831.    days :  array[1..7] of string[2] =
  832.            ('Su','Mo','Tu','We','Th','Fr','Sa');
  833.    MonthLength : array[1..12] of integer =
  834.              (31,28,31,30,31,30,31,31,30,31,30,31);
  835.  
  836. begin
  837.    target := strip( dows ( mm, 1, ccyy), ' ');
  838.    day := 0;
  839.    repeat
  840.       day := succ(day);
  841.    until (Copy ( target, 1, 2) = days[day]) or (day > 7);
  842.  
  843.    if day <= 7 then
  844.    begin
  845.       Col := #179+#197;
  846.       Col := #194+Col+Col+Col+Col+Col+#179+#193;
  847.       Row := #196+#196+#197;
  848.       Row := #195+Row+Row+Row+Row+Row+Row+#196+#196+#180;
  849.       BoxUL ( StartCol, StartRow+2, StartCol+21, StartRow+14, 1, 14);
  850.       for i := 0 to 5 do
  851.          PutStr ( V, Col, StartCol+3+i*3, StartRow+2, 14);
  852.       for i := 0 to 4 do
  853.          PutStr ( H, Row, StartCol, StartRow+4+i*2, 14);
  854.  
  855.       Months :=  'January   February  March     '+
  856.                  'April     May       June      '+
  857.                  'July      August    September '+
  858.                  'October   November  December  ';
  859.  
  860.       Str (CCYY,year);
  861.       Temp := Copy ( Months, 1+(MM-1)*10, 10);
  862.       Temp := Center ( Strip ( Temp, ' ') + ', '+year ,20,' ');
  863.       PutStr (H, Temp , StartCol + 1, StartRow, 14);
  864.  
  865.       for i := 1 to 7 do
  866.          PutStr (H,days[i] + ' ',
  867.                    StartCol+1+(i-1)*3, StartRow+1, 10);
  868.  
  869.       if MM = 1 then
  870.          PreviousMonth := 12
  871.       else
  872.          PreviousMonth := MM - 1;
  873.  
  874.       PreviousMonthLength := MonthLength[PreviousMonth];
  875.       if ( PreviousMonth = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
  876.          PreviousMonthLength := succ(PreviousMonthLength);
  877.       Ypos := StartRow + 3;
  878.       if day > 1 then
  879.       begin
  880.          j := PreviousMonthLength - day + 1;
  881.          for i := 1 to day - 1 do
  882.          begin
  883.             j := succ(j);
  884.             str ( j:2, Temp);
  885.             PutStr ( H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
  886.          end;
  887.          for i := 1 to 7 - day + 1 do
  888.          begin
  889.             str ( i:2, Temp);
  890.             PutStr ( H, Temp , StartCol+1+(day-1)*3+(i-1)*3, Ypos, 14);
  891.          end;
  892.       end { day > 1 }
  893.       else
  894.       begin
  895.          j := PreviousMonthLength - 7;
  896.          for i := 1 to 7 do
  897.          begin
  898.             j := succ(j);
  899.             str ( j:2, Temp);
  900.             PutStr ( H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
  901.          end;
  902.       end { day = 1 };
  903.  
  904.       j := 0;
  905.       Ypos := StartRow + 5;
  906.       NumDays := MonthLength[mm];
  907.       if ( MM = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
  908.          NumDays := succ(NumDays);
  909.  
  910.       if Day > 1 then
  911.          StartDay := 7 - day  + 2
  912.       else
  913.          StartDay := 1;
  914.  
  915.       for i := StartDay to NumDays do
  916.       begin
  917.          Xpos := StartCol+1+j*3;
  918.          Str(i:2,Temp);
  919.          PutStr ( H, Temp, Xpos, Ypos, 14);
  920.          j := succ(j);
  921.          if j = 7 then
  922.          begin
  923.             j := 0;
  924.             Ypos := Ypos + 2;
  925.          end;
  926.       end;
  927.  
  928.       if Day > 1 then
  929.          NextMonth := 42 - ( day - 1 + NumDays)
  930.       else
  931.          NextMonth := 42 - (NumDays + 7);
  932.       for i := 1 to NextMonth do
  933.       begin
  934.          Xpos := StartCol+1+j*3;
  935.          Str(i:2,Temp);
  936.          PutStr ( H, Temp, Xpos, Ypos, 12);
  937.          j := succ(j);
  938.          if j = 7 then
  939.          begin
  940.             j := 0;
  941.             Ypos := Ypos + 2;
  942.          end;
  943.       end;
  944.    end;
  945. end { Calendar };
  946.  
  947. { ---------------------------------
  948.   CALHEAP for given month and year
  949.   --------------------------------- }
  950. Procedure CalHeap ( Page : HeapBuf; MM, CCYY, StartCol, StartRow : Integer);
  951. var
  952.    target     :   string[10];
  953.    year       :   string[4];
  954.    PreviousMonth,
  955.    NextMonth,
  956.    PreviousMonthLength,
  957.    NumDays,
  958.    Xpos, Ypos, StartDay,
  959.    i, j, day  :   integer;
  960.    Temp, Months,
  961.    Col, Row   :   AnyString;
  962.  
  963. const
  964.    days :  array[1..7] of string[2] =
  965.            ('Su','Mo','Tu','We','Th','Fr','Sa');
  966.    MonthLength : array[1..12] of integer =
  967.              (31,28,31,30,31,30,31,31,30,31,30,31);
  968.  
  969. begin
  970.    target := strip( dows ( mm, 1, ccyy), ' ');
  971.    day := 0;
  972.    repeat
  973.       day := succ(day);
  974.    until (Copy ( target, 1, 2) = days[day]) or (day > 7);
  975.  
  976.    if day <= 7 then
  977.    begin
  978.       Col := #179+#197;
  979.       Col := #194+Col+Col+Col+Col+Col+#179+#193;
  980.       Row := #196+#196+#197;
  981.       Row := #195+Row+Row+Row+Row+Row+Row+#196+#196+#180;
  982.       BoxHeap ( Page, StartCol, StartRow+2, StartCol+21, StartRow+14, 1, 14);
  983.       for i := 0 to 5 do
  984.          PutHeap ( Page, V, Col, StartCol+3+i*3, StartRow+2, 14);
  985.       for i := 0 to 4 do
  986.          PutHeap ( Page, H, Row, StartCol, StartRow+4+i*2, 14);
  987.  
  988.       Months :=  'January   February  March     '+
  989.                  'April     May       June      '+
  990.                  'July      August    September '+
  991.                  'October   November  December  ';
  992.  
  993.       Str (CCYY,year);
  994.       Temp := Copy ( Months, 1+(MM-1)*10, 10);
  995.       Temp := Center ( Strip ( Temp, ' ') + ', '+year ,20,' ');
  996.       PutHeap (Page, H, Temp , StartCol + 1, StartRow, 14);
  997.  
  998.       for i := 1 to 7 do
  999.          PutHeap (Page, H,days[i] + ' ',
  1000.                    StartCol+1+(i-1)*3, StartRow+1, 10);
  1001.  
  1002.       if MM = 1 then
  1003.          PreviousMonth := 12
  1004.       else
  1005.          PreviousMonth := MM - 1;
  1006.  
  1007.       PreviousMonthLength := MonthLength[PreviousMonth];
  1008.       if ( PreviousMonth = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
  1009.          PreviousMonthLength := succ(PreviousMonthLength);
  1010.       Ypos := StartRow + 3;
  1011.       if day > 1 then
  1012.       begin
  1013.          j := PreviousMonthLength - day + 1;
  1014.          for i := 1 to day - 1 do
  1015.          begin
  1016.             j := succ(j);
  1017.             str ( j:2, Temp);
  1018.             PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
  1019.          end;
  1020.          for i := 1 to 7 - day + 1 do
  1021.          begin
  1022.             str ( i:2, Temp);
  1023.             PutHeap ( Page, H, Temp , StartCol+1+(day-1)*3+(i-1)*3, Ypos, 14);
  1024.          end;
  1025.       end { day > 1 }
  1026.       else
  1027.       begin
  1028.          j := PreviousMonthLength - 7;
  1029.          for i := 1 to 7 do
  1030.          begin
  1031.             j := succ(j);
  1032.             str ( j:2, Temp);
  1033.             PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
  1034.          end;
  1035.       end { day = 1 };
  1036.  
  1037.       j := 0;
  1038.       Ypos := StartRow + 5;
  1039.       NumDays := MonthLength[mm];
  1040.       if ( MM = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
  1041.          NumDays := succ(NumDays);
  1042.  
  1043.       if Day > 1 then
  1044.          StartDay := 7 - day  + 2
  1045.       else
  1046.          StartDay := 1;
  1047.  
  1048.       for i := StartDay to NumDays do
  1049.       begin
  1050.          Xpos := StartCol+1+j*3;
  1051.          Str(i:2,Temp);
  1052.          PutHeap ( Page, H, Temp, Xpos, Ypos, 14);
  1053.          j := succ(j);
  1054.          if j = 7 then
  1055.          begin
  1056.             j := 0;
  1057.             Ypos := Ypos + 2;
  1058.          end;
  1059.       end;
  1060.  
  1061.       if Day > 1 then
  1062.          NextMonth := 42 - ( day - 1 + NumDays)
  1063.       else
  1064.          NextMonth := 42 - (NumDays + 7);
  1065.       for i := 1 to NextMonth do
  1066.       begin
  1067.          Xpos := StartCol+1+j*3;
  1068.          Str(i:2,Temp);
  1069.          PutHeap ( Page, H, Temp, Xpos, Ypos, 12);
  1070.          j := succ(j);
  1071.          if j = 7 then
  1072.          begin
  1073.             j := 0;
  1074.             Ypos := Ypos + 2;
  1075.          end;
  1076.       end;
  1077.    end;
  1078. end { CalHeap };
  1079.  
  1080. { ------------------------------
  1081.   RWORD returns a string with ST
  1082.   replacing word N of S.
  1083.   ------------------------------ }
  1084. Function RWord  ( S : AnyString;
  1085.                   N : Integer;
  1086.                  ST : AnyString ) : AnyString;
  1087.  
  1088. {   A word is any blank-delimited character sequence,
  1089.     or a string of non-blanks.  There are 7 words in
  1090.     this sentence. }
  1091.  
  1092. var
  1093.    NumWords, start, stop, CurrentAddress, len
  1094.              : integer;
  1095.    Ts, Ats, Tail
  1096.              : AnyString;
  1097.    BlankFound
  1098.              : Boolean;
  1099.  
  1100. begin
  1101.    if Length(S) = 0 then
  1102.       Rword := ''
  1103.    else
  1104.    begin
  1105.       len := Length(S);
  1106.       NumWords := 0;
  1107.       start := 1;
  1108.       stop := len;
  1109.       BlankFound := True;
  1110.       CurrentAddress := 0;
  1111.       repeat
  1112.         CurrentAddress := CurrentAddress + 1;
  1113.         if BlankFound then
  1114.         begin
  1115.            if S[CurrentAddress] <> #32 then
  1116.            begin
  1117.               BlankFound := false;
  1118.               NumWords := succ(NumWords);
  1119.               if NumWords = N then
  1120.                  start := CurrentAddress;
  1121.            end;
  1122.         end
  1123.         else
  1124.         if S[CurrentAddress] = #32 then
  1125.         begin
  1126.            BlankFound := true;
  1127.            if NumWords = N then
  1128.               stop := CurrentAddress;
  1129.         end;
  1130.      until (CurrentAddress = len ) or ( stop < len );
  1131.      if N > NumWords then
  1132.         Rword := S
  1133.      else
  1134.      begin
  1135.         Tail := copy ( S, stop, Length(S)-stop+1 );
  1136.         Ts := copy ( S, 1, start-1 );
  1137.         Ats := St;
  1138.         if (length(Ts) + length(St) + length(Tail)) > 255 then
  1139.            Ats := copy ( St, 1, 255 - length(Ts) - length(tail) );
  1140.         if S[stop] = #32 then
  1141.            Rword := Ts + Ats + Tail
  1142.         else
  1143.            Rword := Ts + Ats;
  1144.      end;
  1145.    end;
  1146. end { Rword };
  1147.  
  1148. { ------------------------------------------
  1149.   WORD returns a string that is word N of S.
  1150.   ------------------------------------------ }
  1151. Function Word  ( S : AnyString;
  1152.                  N : Integer ) : AnyString;
  1153.  
  1154. var
  1155.    NumWords, start, stop, CurrentAddress, len
  1156.              : integer;
  1157.    Ts
  1158.              : AnyString;
  1159.    BlankFound
  1160.              : Boolean;
  1161.  
  1162.  
  1163. begin
  1164.    if Length(S) = 0 then
  1165.       Word := ''
  1166.    else
  1167.    begin
  1168.       NumWords := 0;
  1169.       start := 1;
  1170.       len := length(S);
  1171.       stop := len;
  1172.       BlankFound := True;
  1173.       CurrentAddress := 0;
  1174.  
  1175.       repeat
  1176.          CurrentAddress := CurrentAddress + 1;
  1177.          if BlankFound then
  1178.          begin
  1179.             if S[CurrentAddress] <> #32 then
  1180.             begin
  1181.                BlankFound := false;
  1182.                NumWords := NumWords + 1;
  1183.                if NumWords = N then
  1184.                   start := CurrentAddress;
  1185.             end;
  1186.          end
  1187.          else
  1188.          if S[CurrentAddress] = #32 then
  1189.          begin
  1190.             BlankFound := true;
  1191.             if NumWords = N then
  1192.                stop := CurrentAddress;
  1193.          end;
  1194.       until (stop < len) or (CurrentAddress = len);
  1195.  
  1196.       if N > NumWords then
  1197.          Word := ''
  1198.       else
  1199.       begin
  1200.          if S[stop] <> #32 then
  1201.             stop := succ(stop);
  1202.          Word := copy ( S, start, stop - start );
  1203.       end;
  1204.    end;
  1205. end { Word };
  1206.  
  1207. { ---------------------------------------
  1208.   WORDS returns the number of words in S.
  1209.   --------------------------------------- }
  1210. Function Words ( S : AnyString ) : Integer;
  1211. var
  1212.    NumWords,  CurrentAddress, Len
  1213.              : integer;
  1214.  
  1215. begin
  1216.    S := strip(S,' ');
  1217.    Len := Length(S);
  1218.    if Len = 0 then
  1219.       Words := 0
  1220.    else
  1221.    begin
  1222.       NumWords := 1;
  1223.       CurrentAddress := 1;
  1224.       for CurrentAddress := 1 to Len do
  1225.          if S[CurrentAddress] = #32 then
  1226.             NumWords := NumWords + 1;
  1227.       Words := NumWords;
  1228.    end;
  1229. end { Words };
  1230.  
  1231. { ------------------------------------------
  1232.   WORDIND returns the position of WordNumber
  1233.   in S.
  1234.   ------------------------------------------ }
  1235. Function WordInd (          S : AnyString;
  1236.                    WordNumber : Integer ) : Integer;
  1237.  
  1238. { Example: if S = 'I like Turbo Pascal' then
  1239.               WordInd ( S, 3 ) is 8.  }
  1240.  
  1241. var
  1242.    NumWords,  CurrentAddress, Len, Index
  1243.              : integer;
  1244.    NonBlank :  Boolean;
  1245.  
  1246. begin
  1247.    Len := Length(S);
  1248.    if Len = 0 then
  1249.       WordInd := 0
  1250.    else
  1251.    begin
  1252.       Index := 0;
  1253.       NumWords := 0;
  1254.       CurrentAddress := 0;
  1255.       NonBlank := false;
  1256.       repeat
  1257.          CurrentAddress := CurrentAddress + 1;
  1258.          if NonBlank then
  1259.          begin
  1260.             if S[CurrentAddress] = #32 then
  1261.                NonBlank := false;
  1262.          end
  1263.          else
  1264.          if S[CurrentAddress] <> #32 then
  1265.          begin
  1266.             NumWords := NumWords + 1;
  1267.             if NumWords = WordNumber then
  1268.                Index := CurrentAddress;
  1269.             NonBlank := true;
  1270.          end;
  1271.       until (CurrentAddress = Len) or (Index > 0);
  1272.       WordInd := Index;
  1273.    end;
  1274. end { WordInd };
  1275.  
  1276. { -------------------------
  1277.   SPACE normalizes a string
  1278.   ------------------------- }
  1279. Function Space ( S : AnyString ) : AnyString;
  1280.  
  1281. { A normalized string has no leading or trailing blanks
  1282.   and has only one space between words. }
  1283.  
  1284. var
  1285.    Ts : AnyString;
  1286.    CurrentWord, NumberOfWords : integer;
  1287. begin
  1288.    Ts := '';
  1289.    NumberOfWords := words(S);
  1290.    if NumberOfWords > 0 then
  1291.    begin
  1292.       for CurrentWord := 1 to NumberOfWords do
  1293.       begin
  1294.          if CurrentWord <> NumberOfWords then
  1295.             Ts := Ts + word ( S, CurrentWord ) + ' '
  1296.          else
  1297.             Ts := Ts + word ( S,CurrentWord);
  1298.       end;
  1299.    end;
  1300.   Space := Ts;
  1301. end {Space} ;